
open Asm
open Bigarray

let font_8x16 = [|
	(*	1	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	2	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	3	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	4	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	5	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	6	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	7	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	8	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	9	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	10	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	11	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	12	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	13	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	14	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	15	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	16	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	17	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	17	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	18	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	19	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	20	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	21	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	22	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	23	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	24	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	25	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	26	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	27	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	28	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	29	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	30	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(*	31	*)	0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
	(* <space> ! quot # $ % & ' ( ) * + ; - . / 0 1 2 3 4 5 6 7 8 9 : ; < = > ? *)
	0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x08;0x08;0x08;0x08;0x08;0x00;0x00;0x08;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x36;0x36;0x24;0x24;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x12;0x12;0x24;0x7E;0x24;0x24;0x7E;0x24;0x48;0x48;0x00;0x00;0x00;
	0x00;0x00;0x00;0x08;0x1C;0x24;0x20;0x18;0x04;0x24;0x38;0x08;0x08;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x20;0x50;0x20;0x0C;0x70;0x08;0x14;0x08;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x0E;0x10;0x10;0x18;0x2A;0x24;0x1E;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x10;0x10;0x10;0x10;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x04;0x04;0x08;0x08;0x08;0x08;0x08;0x08;0x04;0x04;0x00;0x00;
	0x00;0x00;0x00;0x00;0x20;0x20;0x10;0x10;0x10;0x10;0x10;0x10;0x20;0x20;0x00;0x00;
	0x00;0x00;0x00;0x00;0x08;0x3E;0x08;0x14;0x14;0x00;0x00;0x00;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x08;0x08;0x08;0x7F;0x08;0x08;0x08;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x18;0x10;0x30;0x20;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x7E;0x00;0x00;0x00;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x18;0x18;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x04;0x04;0x08;0x08;0x10;0x10;0x20;0x20;0x40;0x40;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x3C;0x42;0x42;0x42;0x42;0x42;0x42;0x3C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x08;0x38;0x08;0x08;0x08;0x08;0x08;0x3E;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x38;0x44;0x04;0x08;0x10;0x20;0x44;0x7C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x38;0x44;0x04;0x18;0x04;0x04;0x44;0x38;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x0C;0x14;0x24;0x24;0x7E;0x04;0x04;0x0E;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x3E;0x20;0x20;0x3C;0x02;0x02;0x42;0x3C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x0E;0x10;0x20;0x3C;0x22;0x22;0x22;0x1C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x7E;0x42;0x02;0x04;0x04;0x08;0x08;0x08;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x3C;0x42;0x42;0x3C;0x42;0x42;0x42;0x3C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x3C;0x42;0x42;0x42;0x3E;0x02;0x04;0x78;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x18;0x18;0x00;0x00;0x18;0x18;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x18;0x18;0x00;0x00;0x18;0x30;0x20;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x02;0x0C;0x10;0x60;0x10;0x0C;0x02;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x7E;0x00;0x7E;0x00;0x00;0x00;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x40;0x30;0x08;0x06;0x08;0x30;0x40;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x1C;0x22;0x02;0x02;0x04;0x08;0x00;0x18;0x00;0x00;0x00;0x00;
	(* *)
	0x00;0x00;0x00;0x38;0x44;0x44;0x4C;0x54;0x54;0x4C;0x40;0x44;0x38;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x18;0x08;0x14;0x14;0x14;0x1C;0x22;0x77;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x7C;0x22;0x22;0x3C;0x22;0x22;0x22;0x7C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x1E;0x22;0x40;0x40;0x40;0x40;0x22;0x1C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x78;0x24;0x22;0x22;0x22;0x22;0x24;0x78;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x7E;0x22;0x28;0x38;0x28;0x20;0x22;0x7E;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x7E;0x22;0x28;0x38;0x28;0x20;0x20;0x70;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x1E;0x22;0x40;0x40;0x47;0x42;0x22;0x1C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x77;0x22;0x22;0x3E;0x22;0x22;0x22;0x77;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x3E;0x08;0x08;0x08;0x08;0x08;0x08;0x3E;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x1E;0x04;0x04;0x04;0x44;0x44;0x44;0x38;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x77;0x22;0x24;0x28;0x38;0x24;0x22;0x73;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x70;0x20;0x20;0x20;0x20;0x22;0x22;0x7E;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x77;0x36;0x36;0x2A;0x2A;0x22;0x22;0x77;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0xE7;0x62;0x52;0x52;0x4A;0x4A;0x46;0xE6;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x1C;0x22;0x41;0x41;0x41;0x41;0x22;0x1C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x7C;0x22;0x22;0x22;0x3C;0x20;0x20;0x70;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x1C;0x22;0x41;0x41;0x41;0x41;0x22;0x1C;0x1F;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x7C;0x22;0x22;0x22;0x3C;0x24;0x22;0x71;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x3A;0x46;0x40;0x3C;0x02;0x02;0x62;0x5C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x7F;0x49;0x08;0x08;0x08;0x08;0x08;0x1C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x77;0x22;0x22;0x22;0x22;0x22;0x22;0x1C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0xE7;0x42;0x42;0x24;0x24;0x24;0x18;0x18;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x77;0x22;0x22;0x2A;0x2A;0x2A;0x2A;0x14;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x77;0x22;0x14;0x08;0x08;0x14;0x22;0x77;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x77;0x22;0x14;0x14;0x08;0x08;0x08;0x1C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x3E;0x22;0x04;0x08;0x08;0x10;0x22;0x3E;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x1C;0x10;0x10;0x10;0x10;0x10;0x10;0x10;0x10;0x1C;0x00;0x00;
	0x00;0x00;0x00;0x40;0x40;0x20;0x20;0x10;0x10;0x10;0x08;0x08;0x08;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x70;0x10;0x10;0x10;0x10;0x10;0x10;0x10;0x10;0x70;0x00;0x00;
	0x00;0x00;0x00;0x10;0x10;0x28;0x44;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0xFF;
	(* *)
	0x00;0x00;0x00;0x00;0x10;0x08;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x3C;0x42;0x3E;0x42;0x46;0x3B;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0xC0;0x40;0x5C;0x62;0x42;0x42;0x62;0xDC;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x3A;0x46;0x40;0x40;0x42;0x3C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x06;0x02;0x3A;0x46;0x42;0x42;0x46;0x3B;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x3C;0x42;0x7E;0x40;0x40;0x3E;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x0E;0x10;0x7E;0x10;0x10;0x10;0x10;0x7E;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x3B;0x46;0x42;0x42;0x46;0x3A;0x02;0x3C;0x00;0x00;
	0x00;0x00;0x00;0x00;0x60;0x20;0x2C;0x32;0x22;0x22;0x22;0x77;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x08;0x00;0x38;0x08;0x08;0x08;0x08;0x3E;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x08;0x00;0x3C;0x04;0x04;0x04;0x04;0x04;0x04;0x78;0x00;0x00;
	0x00;0x00;0x00;0x00;0x60;0x20;0x2F;0x24;0x38;0x28;0x24;0x67;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x18;0x08;0x08;0x08;0x08;0x08;0x08;0x3E;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0xD2;0x6D;0x49;0x49;0x49;0xED;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x6C;0x32;0x22;0x22;0x22;0x77;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x3C;0x42;0x42;0x42;0x42;0x3C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x6C;0x32;0x22;0x22;0x22;0x3C;0x20;0x70;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x3B;0x46;0x42;0x42;0x46;0x3A;0x02;0x07;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x6E;0x30;0x20;0x20;0x20;0x7C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x3E;0x42;0x3C;0x02;0x42;0x7C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x20;0x7C;0x20;0x20;0x20;0x22;0x1C;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x66;0x22;0x22;0x22;0x26;0x1B;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0xE7;0x42;0x24;0x24;0x18;0x18;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x77;0x22;0x2A;0x2A;0x2A;0x14;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x66;0x24;0x18;0x18;0x24;0x66;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x77;0x22;0x22;0x14;0x14;0x08;0x08;0x38;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x3E;0x24;0x08;0x10;0x22;0x3E;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x08;0x10;0x10;0x10;0x20;0x10;0x10;0x10;0x08;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x10;0x10;0x10;0x10;0x10;0x10;0x10;0x10;0x10;0x10;0x00;0x00;
	0x00;0x00;0x00;0x00;0x20;0x10;0x10;0x10;0x08;0x10;0x10;0x10;0x20;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x32;0x4C;0x00;0x00;0x00;0x00;0x00;0x00;0x00;
	0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00;0x00
	(* extended ASCII would follow *)
|]

module R = struct
	let misc_write = 0x3C2
	let seq_index = 0x3C4
	let seq_data = 0x3C5
	let crtc_index = 0x3D4
	let crtc_data = 0x3D5
	let gc_index = 0x3CE
	let gc_data = 0x3CF
	let ac_index = 0x3C0
	let ac_write = 0x3C0
	let instat_read = 0x3DA
end

let write_font font height =
	(* save registers *)
	out8 R.seq_index 2;
	let seq2 = in8 R.seq_data in
	out8 R.seq_index 4;
	let seq4 = in8 R.seq_data in
	out8 R.gc_index 4;
	let gc4 = in8 R.gc_data in
	out8 R.gc_index 5;
	let gc5 = in8 R.gc_data in
	out8 R.gc_index 6;
	let gc6 = in8 R.gc_data in
	(* turn off even-odd addressing *)
	out8 R.seq_index 4;
	out8 R.seq_data (seq4 lor 0x04);
	out8 R.gc_index 5;
	out8 R.gc_data (gc5 land (lnot 0x10));
	out8 R.gc_index 6;
	out8 R.gc_data (gc6 land (lnot 0x02));
	(* write font to plane P4 *)
	let p = 2 land 3 in
	let pmask = 1 lsl p in
	(* set read plane *)
	out8 R.gc_index 4;
	out8 R.gc_data p;
	(* set write plane *)
	out8 R.seq_index 2;
	out8 R.seq_data pmask;
	(* write font 0 *)
	let vga = array8 0xB8000l 8000 in
	for i = 0 to Array.length font / 16 - 1 do
		let buf = Array1.of_array int8_unsigned c_layout
				(Array.sub font (i * 16) 16) in
		Array1.blit
			buf (Array1.sub vga (i * 32) 16);
	done;
	(* restore registers *)
	out8 R.seq_index 2;
	out8 R.seq_data seq2;
	out8 R.seq_index 4;
	out8 R.seq_data seq4;
	out8 R.gc_index 4;
	out8 R.gc_data gc4;
	out8 R.gc_index 5;
	out8 R.gc_data gc5;
	out8 R.gc_index 6;
	out8 R.gc_data gc6
	
let init () =
	write_font font_8x16 16
